home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / top / top.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  13.2 KB  |  332 lines
  1. (herald (orbit_top top))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.     
  26. (define bogus-filename (->filename 'anonymous))
  27.  
  28. (define (orbit exp . env)
  29.   (let ((env (if env (car env) (repl-env))))
  30.     (bind ((*noise-flag* nil)
  31.            (*debug-flag* nil)
  32.            (*noise+error*    (error-output))
  33.            (*noise+terminal* null-port)
  34.            (*noise-stream*   null-port))
  35.       (receive (comex #f)
  36.                (compile `(,syntax/lambda () ,exp)
  37.                         standard-early-binding-env
  38.                         (env-syntax-table env)
  39.                         bogus-filename
  40.                         '(anonymous))
  41.         (instantiate-comex comex env)))))
  42.  
  43. (define (compile exp support syntax filename h)
  44.   (front-init support
  45.               (lambda ()
  46.                 (generate-init 
  47.                  (lambda () 
  48.                    (assemble-init 
  49.                     (lambda ()
  50.                       (really-compile exp syntax filename h))))))))
  51.  
  52. (define (really-compile exp syntax filename h)
  53.   (receive (tree infex)
  54.            (make-code-tree+support `(,syntax/lambda () ,exp) syntax)
  55.     (receive (a b c)
  56.              (analyze tree)
  57.       (generate tree)
  58.       (let ((comex (create-comex filename h a b c (assemble))))
  59.         (if (not *debug-flag*) (erase-all tree))
  60.         (return comex infex)))))
  61.  
  62. (define (cl exp . debug?)
  63.   (let ((debug? (if (null? debug?) nil (car debug?))))
  64.     (cond ((not (procedure? exp))
  65.            (real-cl exp debug?))
  66.           ((disclose exp)
  67.            => (lambda (exp) (real-cl exp debug?)))
  68.           (else
  69.            (cl (error "cannot get source code for ~S" exp) debug?)))))
  70.  
  71. (define (real-cl exp debug?)
  72.   (bind ((*noise-flag* t)
  73.          (*debug-flag* debug?)
  74.          (*assembly-comments?* t)
  75.          (*noise+error*    (error-output))
  76.          (*noise+terminal* (terminal-output))
  77.          (*noise-stream*   (terminal-output)))
  78.     (cl-compile `(,syntax/lambda () ,exp)
  79.                 base-early-binding-env
  80.                 (orbit-syntax-table)
  81.                 bogus-filename
  82.                 '(cl))))
  83.  
  84. (define (cl-compile exp support syntax filename h)
  85.   (front-init support
  86.               (lambda ()
  87.                 (generate-init 
  88.                  (lambda () 
  89.                    (assemble-init 
  90.                     (lambda ()
  91.                       (really-compile exp syntax filename h)
  92.                       (quicklist))))))))
  93.  
  94. (define (make-node-tree exp)
  95.   (bind ((*debug-flag* nil)
  96.          (*noise-flag* nil)
  97.          (*noise+error*    (error-output))
  98.          (*noise+terminal* (terminal-output))
  99.          (*noise-stream*   (terminal-output)))
  100.     (front-init standard-early-binding-env
  101.                 (lambda ()
  102.                   (receive (tree supex)
  103.                            (make-code-tree+support `(,syntax/lambda () ,exp)
  104.                                                    standard-syntax-table)
  105.                     (ignore supex)
  106.                     tree)))))
  107.  
  108. (lset *object-file-extension* 'o)
  109. (lset *information-file-extension* 'i)
  110. (lset *noise-file-extension* 'n)
  111.  
  112. (define (compile-file file-spec)
  113.   (comfile-bind file-spec file-spec really-comfile))
  114.  
  115. (define comfile compile-file)
  116.  
  117. (define (comfile2 in-file-spec out-file-spec)
  118.   (comfile-bind in-file-spec out-file-spec really-comfile))
  119.  
  120. (define (totally-comfile in-file-spec out-file-spec read-table syntax support)
  121.   (comfile-bind in-file-spec
  122.                 out-file-spec
  123.                 (lambda (in-filename out-filename)
  124.                   (really-totally-comfile in-filename out-filename
  125.                                           read-table syntax support))))
  126.  
  127. (define (create-support in-file-spec . out-file-spec)
  128.   (comfile-bind in-file-spec
  129.                 (if (null? out-file-spec) in-file-spec (car out-file-spec))
  130.                 (lambda (in-filename out-filename)
  131.                   (receive (exp support syntax #f)
  132.                            (read-file in-filename)
  133.                     (front-init support
  134.                       (lambda ()
  135.                         (receive (tree infex)
  136.                           (make-code-tree+support `(,syntax/lambda () ,exp)
  137.                                                   syntax)
  138.                           (erase-all tree)
  139.                           (write-support-file infex out-filename))))))))
  140.  
  141. (define (comfile-bind in-file-spec out-file-spec cont)
  142.   (let ((in-filename (->filename in-file-spec)) 
  143.         (out-filename (->filename out-file-spec)))
  144.     (with-open-ports ((noise-stream
  145.                        (open (filename-with-type out-filename
  146.                                                  *noise-file-extension*)
  147.                              '(out))))
  148.       (bind ((*debug-flag* nil)
  149.              (*noise-flag* nil)
  150.              (*noise+error* (make-broadcast-port noise-stream (error-output)))
  151.              (*noise+terminal* (make-broadcast-port noise-stream 
  152.                                                     (terminal-output)))
  153.              (*noise-stream* noise-stream))
  154.         (cont in-filename out-filename)))))
  155.  
  156. (define (really-comfile in-filename out-filename)
  157.     (receive (exp support syntax h)
  158.              (read-file in-filename)
  159.       (receive (comex infex)
  160.                (compile exp support syntax in-filename h)
  161.         (write-support-file infex out-filename)
  162.         (write-object-file comex out-filename)
  163.         t)))
  164.  
  165. (define (really-totally-comfile in-filename out-filename read-table syntax support)
  166.   (receive (exp #f #f h)
  167.            (really-read-file in-filename read-table nil)
  168.     (receive (comex infex)
  169.              (compile exp support syntax in-filename h)
  170.       (write-support-file infex out-filename)
  171.       (write-object-file comex out-filename)
  172.       t)))
  173.  
  174. (define (write-object-file comex filename)
  175.   (write-comex-to-file (filename-with-type filename *object-file-extension*)
  176.                        comex))
  177.                            
  178. ;;; This isn't used anywhere
  179. ;;;(define-simple-switch orbit-macro-definition-env locale? user-env)
  180. ;;;(define tc-macro-definition-env orbit-macro-definition-env)
  181.  
  182. (define orbit-syntax-table
  183.   (make-simple-switch 'orbit-syntax-table
  184.                       true?
  185.                       (env-syntax-table user-env)))
  186.  
  187. (define tc-syntax-table orbit-syntax-table)
  188.  
  189. ;;; Bizarro new interface
  190.  
  191. (define (make-compiler id)
  192.   (let ((syntax standard-syntax-table)
  193.         (read standard-read-table)
  194.         (bindings standard-early-binding-env))
  195.     (object (lambda (from . to)
  196.               (totally-comfile from
  197.                                (if (null? to) from (car to))
  198.                                read syntax bindings))
  199.       ((compiler-syntax-table      self) syntax)
  200.       ((compiler-read-table        self) read)
  201.       ((compiler-early-binding-env self) bindings)
  202.       (((setter compiler-syntax-table) self new)
  203.        (set syntax new))
  204.       (((setter compiler-read-table) self new)
  205.        (set read new))
  206.       (((setter compiler-early-binding-env) self new)
  207.        (set bindings new))
  208.       ((identification self) id))))
  209.  
  210. (define-settable-operation compiler-syntax-table)
  211. (define-settable-operation compiler-read-table)
  212. (define-settable-operation compiler-early-binding-env)
  213.  
  214. (define (make-early-binding-locale super name)
  215.   (make-definition-env super name))
  216.  
  217. (define (make-empty-early-binding-locale name)
  218.   (make-definition-env false name))
  219.  
  220. (define (load-early-bindings file-spec . early-binding-env)
  221.   (let ((table (reload-support file-spec)))
  222.     (instantiate-definition-table (if (null? early-binding-env)
  223.                                       standard-early-binding-env
  224.                                       (car early-binding-env))
  225.                                   table)))
  226.  
  227. ;;; Reading the file in
  228.  
  229. (define (read-file filename)
  230.   (really-read-file filename nil t))
  231.  
  232. (define (really-read-file filename read-table herald?)
  233.   (with-open-ports ((input (open-source filename (source-file-extension))))
  234.     (let ((name (port-truename input)))
  235.       (format *noise+terminal* "~%;Beginning compilation on ")
  236.       (if (fx<= (fx+ (hpos *noise+terminal*) (print-width name))
  237.                 (line-length *noise+terminal*))
  238.           (format *noise+terminal* "~A~2%" name)
  239.           (format *noise+terminal* "~%; ~A~%" name)))
  240.     (let* ((first (read input))
  241.            (herald-obj (cond ((and (pair? first)
  242.                                    (eq? (car first) 'herald))
  243.                               (parse-herald (cadr first) (cddr first)))
  244.                              (herald?
  245.                               (error "file ~S has no herald form"
  246.                                      (filename->string filename)))
  247.                              (else nil))))
  248.       (bind (((port-read-table input) 
  249.                 (cond (read-table => identity)
  250.                       ((herald-read-table herald-obj)
  251.                        (eval (herald-read-table herald-obj) user-env))
  252.                       (else
  253.                        standard-read-table))))
  254.         (iterate loop ((forms '()) 
  255.                        (read-form (if herald-obj (read input) first)))
  256.           (cond ((not (eof? read-form))
  257.                  (loop (cons read-form forms) (read input)))
  258.                 (herald?
  259.                  (return `(,syntax/lambda () . ,(reverse! forms))
  260.                          (if (herald-environment herald-obj)
  261.                              (eval (herald-environment herald-obj) 
  262.                                    user-env)
  263.                              standard-early-binding-env)
  264.                          (if (herald-syntax-table herald-obj)
  265.                              (eval (herald-syntax-table herald-obj) 
  266.                                    user-env)
  267.                              (orbit-syntax-table))
  268.                          (cdr first)))
  269.                 (else
  270.                  (return `(,syntax/lambda () . ,(reverse! forms))
  271.                          nil nil
  272.                          (if herald-obj
  273.                              (cdr first) 
  274.                              (list (filename-name filename)))))))))))
  275.  
  276. (define (open-source filename extension)
  277.   (or (maybe-open filename '(in))
  278.       (maybe-open (filename-with-type filename extension) '(in))
  279.       (open filename '(in))))
  280.  
  281. (lset *modules* (make-table '*modules*))
  282.  
  283. (define (orbit-vax-setup directory)
  284.   (set *object-file-extension* 'vo)
  285.   (set *information-file-extension* 'vi)
  286.   (set *noise-file-extension* 'vn)
  287.   (set (table-entry *modules* 'constants) `(,directory vconstants))
  288.   (set (table-entry *modules* 'primops)   `(,directory vaxprimops))
  289.   (set (table-entry *modules* 'arith)     `(,directory vaxarith))
  290.   (set (table-entry *modules* 'low)       `(,directory vaxlow))
  291.   (orbit-setup directory)
  292.   nil)
  293.  
  294. (define (orbit-m68-setup directory)
  295.   (set *object-file-extension* 'mo)
  296.   (set *information-file-extension* 'mi)
  297.   (set *noise-file-extension* 'mn)
  298.   (set (table-entry *modules* 'constants) `(,directory mconstants))
  299.   (set (table-entry *modules* 'primops)   `(,directory m68primops))
  300.   (set (table-entry *modules* 'arith)     `(,directory m68arith))
  301.   (set (table-entry *modules* 'low)       `(,directory m68low))
  302.   (orbit-setup directory)
  303.   nil)
  304.  
  305. (define (orbit-setup directory)
  306.   (set (table-entry *modules* 'base)       `(,directory base))
  307.   (set (table-entry *modules* 'locations)  `(,directory locations))
  308.   (set (table-entry *modules* 'carcdr)     `(,directory carcdr))
  309.   (set (table-entry *modules* 'predicates) `(,directory predicates))
  310.   (set (table-entry *modules* 'open)       `(,directory open))
  311.   (set (table-entry *modules* 'aliases)    `(,directory aliases))
  312.   (set (table-entry *modules* 'genarith)    `(,directory genarith))
  313.   t)
  314.  
  315. (define (module-name->filename name)
  316.   (->filename (cond ((table-entry *modules* name)
  317.                      => identity)
  318.                     ((and (pair? name)
  319.                      (table-entry *modules* (car name)))
  320.                      => (lambda (n)
  321.                           (cons n (cdr name))))
  322.                     (else name))))
  323.  
  324. ;;; FE/TOP
  325. (define (reload-support module-name)
  326.   (set (table-entry definition-tables module-name) '#f)
  327.   (get-definition-table module-name))
  328.  
  329.  
  330.     
  331.  
  332.